home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / usenet / sources / volume90 / aplictns / xscheme2 / part01 / macros.s < prev    next >
Text File  |  1990-04-14  |  3KB  |  121 lines
  1. (define %compile compile)
  2.  
  3. (define (%expand-macros expr)
  4.   (if (pair? expr)
  5.     (if (symbol? (car expr))
  6.       (let ((expander (get (car expr) '%syntax)))
  7.         (if expander
  8.           (expander expr)
  9.           (let ((expander (get (car expr) '%macro)))
  10.             (if expander
  11.               (%expand-macros (expander expr))
  12.               (cons (car expr) (%expand-list (cdr expr)))))))
  13.       (%expand-list expr))
  14.     expr))
  15.  
  16. (define (%expand-list lyst)
  17.   (if (pair? lyst)
  18.     (cons (%expand-macros (car lyst)) (%expand-list (cdr lyst)))
  19.     lyst))
  20.  
  21. (define (compile expr #!optional env)
  22.   (if (default-object? env)
  23.     (%compile (%expand-macros expr))
  24.     (%compile (%expand-macros expr) env)))
  25.  
  26. (put 'macro '%macro
  27.   (lambda (form)
  28.     (list 'put
  29.           (list 'quote (cadr form))
  30.           (list 'quote '%macro)
  31.           (caddr form))))
  32.  
  33. (macro syntax
  34.   (lambda (form)
  35.     #f))
  36.  
  37. (macro compiler-syntax
  38.   (lambda (form)
  39.     (list 'put
  40.           (list 'quote (cadr form))
  41.           (list 'quote '%syntax)
  42.           (caddr form))))
  43.  
  44. (compiler-syntax quote
  45.   (lambda (form) form))
  46.       
  47. (compiler-syntax lambda
  48.   (lambda (form)
  49.     (cons
  50.       'lambda
  51.       (cons
  52.         (cadr form)
  53.         (%expand-list (cddr form))))))
  54.  
  55. (compiler-syntax define
  56.   (lambda (form)
  57.     (cons
  58.       'define
  59.       (cons
  60.         (cadr form)
  61.         (%expand-list (cddr form))))))
  62.   
  63. (compiler-syntax set!
  64.   (lambda (form)
  65.     (cons
  66.       'set!
  67.       (cons
  68.         (cadr form)
  69.         (%expand-list (cddr form))))))
  70.  
  71. (define (%cond-expander lyst)
  72.   (cond
  73.       ((pair? lyst)
  74.        (cons
  75.          (if (pair? (car lyst))
  76.            (%expand-list (car lyst))
  77.            (car lyst))
  78.          (%cond-expander (cdr lyst))))
  79.       (else lyst)))
  80.  
  81. (compiler-syntax cond
  82.   (lambda (form)
  83.     (cons 'cond (%cond-expander (cdr form)))))
  84.  
  85. ; The following code for expanding let/let*/letrec was donated by:
  86. ;
  87. ; Harald Hanche-Olsen
  88. ; The University of Trondheim
  89. ; The Norwegian Institute of Technology
  90. ; Division of Mathematics
  91. ; N-7034 Trondheim NTH
  92. ; Norway
  93.  
  94. (define (%expand-let-assignment pair)
  95.   (if (pair? pair)
  96.     (cons
  97.       (car pair)
  98.       (%expand-macros (cdr pair)))
  99.     pair))
  100.  
  101. (define (%expand-let-form form)
  102.   (cons
  103.     (car form)
  104.     (cons
  105.       (let ((lyst (cadr form)))
  106.         (if (pair? lyst)
  107.           (map %expand-let-assignment lyst)
  108.           lyst))
  109.       (%expand-list (cddr form)))))
  110.  
  111. (compiler-syntax let %expand-let-form)
  112. (compiler-syntax let* %expand-let-form)
  113. (compiler-syntax letrec %expand-let-form)
  114.  
  115. (macro define-integrable
  116.   (lambda (form)
  117.     (cons 'define (cdr form))))
  118.  
  119. (macro declare
  120.   (lambda (form) #f))
  121.